perm filename PPROC.SAI[PNT,HE]10 blob
sn#526830 filedate 1980-07-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00004 00003 ! begin,cobegin,end,coend,if,for,while,do
C00008 00004 ! case
C00011 00005 ! decl,simpledecl,arraydecl,procdecl,return
C00023 00006 ! setbase,wrist,gather,readwrist,setstiff
C00028 00007 ! vt05,print,prompt,abort,sigwait,pause,enable,val
C00032 00008 ! affix,unfix
C00035 00009 ! coordproc
C00037 00010 ! assignproc,setspeedproc
C00041 00011 ! loadproc
C00050 00012 ! dumpproc
C00057 00013 END "PPROC"
C00058 ENDMK
C⊗;
ENTRY;
BEGIN "PPROC"
DEFINE $$PRGID=TRUE; DEFINE $PPROC=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
INTERNAL SIMPLE INTEGER PROCEDURE UPLEVEL(INTEGER OFFSET);
BEGIN
INTEGER I;
I ← (OFFSET +1) LSH -8 ; ! this gives the level ;
I ← (I+1) LSH 8 ; ! this gives the next level ;
RETURN(I);
END;
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE RPARSE(STRING S);
BEGIN
WORD_READ(S);
RETURN(PARSE);
END;
RPTR(EXPR$)PROCEDURE RGTSCEXP(STRING S1,ERR);
BEGIN
WORD_READ(S1);
RETURN($$GTANYEXP(ERR,#SC));
END;
RPTR(EXPR$) PROCEDURE $RAPPEND(RPTR(RSTACK)R);
BEGIN
RTRIM(R);
RETURN($AAPPEND(RSTACK:STACK[R]));
END;
RPTR(EXPR$) PROCEDURE $GTIDREF(INTEGER TYPE; STRING S);
BEGIN ! like $$gtidref except does not return sym ptr;
RPTR(SYMBOL)SYM;
RETURN($$GTIDREF(TYPE,SYM,S));
END;
! begin,cobegin,end,coend,if,for,while,do;
INTERNAL RECURSIVE PROCEDURE BEGINPROC;
BEGIN RPTR(BLOCKREC)B; RPTR(RSTACK)BPTR; INTEGER TMPOFF;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
BPTR←NEW_RSTACK;
DO BEGIN
RPUSH(BPTR,PARSE);
WORD2_READ(";","END");
END UNTIL EQU(TOKEN,"END");
! kill any new variables defined in this block ;
RPUSH(BPTR,$PCD11(XXPKVAR,BLOCKREC:#ARGS[CURBLOCK]));
$$PCODE←$RAPPEND(BPTR);
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
END;
INTERNAL RECURSIVE PROCEDURE COBEGINPROC;
BEGIN
RPTR(RSTACK)CBPTR;
INTEGER TMPOFF,N$TMPOFF;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
N$TMPOFF←UPLEVEL($TMPOFF);
CBPTR←NEW_RSTACK;
DO BEGIN
RPTR(BLOCKREC)B; RPTR(EXPR$)P;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
$TMPOFF←N$TMPOFF;
P←PARSE;
RPUSH(CBPTR,P);
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
WORD2_READ(";","COEND");
END UNTIL EQU(TOKEN,"COEND");
RTRIM(CBPTR);
$$PCODE←$COBEGPCODE(RSTACK:STACK[CBPTR]);
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
END;
INTERNAL PROCEDURE ENDPROC(STRING E("END"));
BEGIN
STOKEN←TRUE;
$$PCODE←NULL_RECORD;
END;
INTERNAL RECURSIVE PROCEDURE IFPROC;
BEGIN
RPTR(EXPR$)COND,A,B;
COND←$$GTANYEXP("condition part of IF statement",#SC);
A←RPARSE("THEN");
GTOKEN;
B←NULL_RECORD;
IF EQU(TOKEN,"ELSE") THEN B←PARSE
ifc false thenc ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
ELSE ERROR("Only ELSE or ; allowed after then part"); endc
ELSE STOKEN←TRUE;
$$PCODE←$IFPCODE(COND,A,B);
END;
INTERNAL RECURSIVE PROCEDURE FORPROC;
BEGIN
RPTR(EXPR$)SC,LB,UB,STE,STATE;
SC←$GTIDREF(#SC,"index of FOR");
$SCLST←NULL;
LB←RGTSCEXP("←","FOR statement");
STE←RGTSCEXP("STEP","FOR statement");
UB←RGTSCEXP("UNTIL","FOR statement");
STATE←RPARSE("DO");
$$PCODE←$FORPCODE(SC,LB,STE,UB,STATE);
END;
INTERNAL RECURSIVE PROCEDURE WHILEPROC;
BEGIN
RPTR(EXPR$)COND,S;
COND←$$GTANYEXP("condition part of WHILE statement",#SC);
S←RPARSE("DO");
$$PCODE←$WHILEPCODE(COND,S);
END;
INTERNAL RECURSIVE PROCEDURE DOPROC;
BEGIN
RPTR(EXPR$)S,COND;
S←PARSE;
COND←RGTSCEXP("UNTIL","UNTIL part of DO statement");
$$PCODE←$DOPCODE(S,COND);
END;
! case;
RECURSIVE RPTR(CASE$) PROCEDURE CASE$REC (RPTR(CASE$)CASEXP;INTEGER NUM);
BEGIN
! creates a new record linked with casexp and fills in the
num field the number num;
RPTR(CASE$)TEMP;
TEMP←NEW_RECORD(CASE$);
CASE$:NEXT[TEMP]←CASEXP;
CASE$:NUM[TEMP]←NUM;
RETURN(TEMP);
END;
RECURSIVE RPTR(CASE$)PROCEDURE CASE$EXP (RPTR(CASE$)CASEXP;RPTR(EXPR$)EXP);
BEGIN
! inserts the pointer expr in the field body of casexp;
IF EXP= NULL!RECORD THEN EXP←$PCD1(XXNOOP);
CASE$:BODY[CASEXP]←EXP;
RETURN(CASEXP);
END;
INTERNAL RECURSIVE PROCEDURE CASEPROC;
BEGIN
RPTR(EXPR$)EXINDEX,EXS; RPTR(CASE$)EXCASE;
BOOLEAN RDELSE;INTEGER MAXNUM;
! $COMPILE←$COMPILE+1;
RDELSE←FALSE;MAXNUM←-1;
EXCASE←NULL!RECORD;
EXINDEX←$$GTANYEXP(" CASE", #SC); ! get index;
WWORD_READ("OF","BEGIN");
GTOKEN;STOKEN←TRUE;
IF TOKEN="[" OR EQU(TOKEN,"ELSE")
THEN BEGIN "numbered"
INTEGER NUM;
DO BEGIN
WORD2_READ("[","ELSE");
IF EQU(TOKEN,"ELSE")
THEN IF RDELSE THEN ERROR ("only one ELSE in CASE!")
ELSE BEGIN
RDELSE←TRUE;NUM←#ELSE;
END
ELSE BEGIN
NUM←GE_ZERO_READ;
MAXNUM← MAXNUM MAX NUM;
WORD_READ("]");
END;
! construct the record with num or #else in field num;
EXCASE←CASE$REC(EXCASE,NUM);
GTOKEN; STOKEN←TRUE;
IF TOKEN≠"[" AND ¬EQU(TOKEN,"ELSE")
THEN BEGIN
EXS←PARSE;
WORD2_READ(";","END") ;
EXCASE←CASE$EXP(EXCASE,EXS);
STOKEN←FALSE;
END;
END UNTIL EQU(TOKEN,"END");
END "numbered"
ELSE
WHILE ¬EQU(TOKEN,"END") DO
BEGIN "unnumbered"
EXS←PARSE;
WORD2_READ(";","END");
MAXNUM←MAXNUM+1;
EXCASE←CASE$EXP(CASE$REC(EXCASE,MAXNUM),EXS);
END "unnumbered";
IF MAXNUM≠-1 THEN
$$PCODE←$CASEPCODE(EXINDEX,EXCASE,RDELSE,MAXNUM);
! $COMPILE←$COMPILE-1;
END;
! decl,simpledecl,arraydecl,procdecl,return;
PROCEDURE PR_SAVE(RPTR(PROC)PSYM;STRING SAVEBODY);
BEGIN
PROC:BODY[PSYM]←SAVEBODY;
END;
INTERNAL PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
BEGIN "procedure declaration"
STRING ATOKEN;INTEGER NARGS,SYMACCS;
INTEGER TMPOFF;
INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
STRING ARRAY ARGNAME[1:10];
RPTR(SYMBOL) ARRAY SYMARR[1:10];
RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
$LEVEL←1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN
ERROR("Need undeclared identifier for procedure declaration");
ATOKEN←TOKEN;
NARGS←0; TMPOFF←$TMPOFF; $TMPOFF←UPLEVEL(TMPOFF);! starting value ;
GTOKEN;
IF TOKEN="(" THEN
DO BEGIN "procedure with parameters"
INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
GTOKEN;
ARRDECL←FALSE;
CACCESS←#REFTYP; SYMACCS←#SIMPLE;
IF EQU(TOKEN,"VALUE") THEN CACCESS←0
ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
ELSE STOKEN←TRUE;
GTOKEN;
FOR CTYPE←#SC STEP 1 UNTIL #EV DO
IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
IF NOT(#SC≤CTYPE≤#EV) THEN ERROR("Need basic data type declaration here");
GTOKEN;
DATPTR←NULL_RECORD;
IF EQU(TOKEN,"ARRAY") THEN
BEGIN CACCESS←#REFTYP+#ARRTYP;
ARRDECL←TRUE; SYMACCS←#ARRAY;
END ELSE STOKEN←TRUE;
DO BEGIN "get list of parameters"
INTEGER I;
IF NARGS>10 THEN ERROR("Cant take more than 10 parameters");
GTOKEN;
! now check if we have used this before ;
IF NOT(#TOKEN≠UNDECLARED_TYPE OR #TOKEN≠ID_TYPE) THEN
ERROR("Need undeclared or id token here");
FOR I←1 STEP 1 UNTIL NARGS DO
IF EQU(TOKEN,ARGNAME[I]) THEN DONE;
IF EQU(TOKEN,ATOKEN) THEN I←NARGS;
IF I≠NARGS+1 THEN ERROR(TOKEN&" has already been used in this procedure");
NARGS←NARGS+1;
TYPE[NARGS]←CTYPE; ACCESS[NARGS]←CACCESS;
ARGNAME[NARGS]←TOKEN;
ARGOFF[NARGS]←$TMPOFF;
IF ARRDECL THEN
BEGIN "array in argument list"
RPTR(EXPR$)E;
INTEGER I; I←0;
WORD_READ("[");
DO BEGIN "no of arguments"
E←$$GTANYEXP("for field of array declaration",#SC);
E←RGTSCEXP(":","for dimension field of array dec");
I←I+1;
WORD2_READ(",","]");
END "no of arguments" UNTIL TOKEN="]";
IF I>5 THEN ERROR("Array dimension must be less than 5");
ARRAYREC:#DIM[DATPTR←NEW_RECORD(ARRAYREC)]←ARRDIM[NARGS]←I;
END "array in argument list";
SYMBOL:OFFSET[SYMARR[NARGS]←MK_SYM(ARGNAME[NARGS],
TYPE[NARGS],DATPTR,SYMACCS)] ← $TMPOFF;
$TMPOFF←$TMPOFF+1;
GTOKEN;
END "get list of parameters" UNTIL TOKEN≠",";
IF TOKEN≠")" AND TOKEN≠";" THEN ERROR("Need ; or , or ) here");
END "procedure with parameters" UNTIL TOKEN=")"
ELSE STOKEN←TRUE;
WORD_READ(";");
PSYM←MK_PR(NARGS,ARGNAME,TYPE,ACCESS,ARRDIM);
SYM←CURPROC←MK_SYM(ATOKEN,OBTYPE,PSYM,#PROCEDURE);
SYMBOL:OFFSET[CURPROC]←$SYMOFF;
CURBLOCK←BLOCKIFY(NARGS,SYMARR);
BLOCKREC:LEVEL[CURBLOCK]←$LEVEL;
PBODY←PARSE;
PR_SAVE(PSYM,$CLNSAVE);
$$PCODE←$PRCDCLPCODE(SYM,PBODY);
ENSYM$(SYM);
$SYMOFF←$SYMOFF+1;
END;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...
EVENT <id>,<id>,...;
INTERNAL PROCEDURE SIMPLEDECL(INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)ARRAY SPTR[1:10];
INTEGER I,J; J←0;
DO BEGIN "A"
IF J=10 THEN ERROR("Can only declare 10 variables in a declaration");
GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("undeclared identifier required")
ELSE BEGIN "check current list"
INTEGER K;
FOR K←1 STEP 1 UNTIL J DO
IF EQU(SYMBOL:PNAME[SPTR[K]],TOKEN) THEN DONE;
IF K=J+1 THEN SPTR[J←J+1]←NNWR(TOKEN,OBTYPE)
ELSE ERROR(TOKEN&" is not undeclared");
END "check current list";
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("; or , required");
END "A" UNTIL FINAL;
IF CURBLOCK
THEN BEGIN "temp vars"
FOR I←1 STEP 1 UNTIL J DO
BEGIN INSRTSYMTREE(SPTR[I],CURBLOCK);
SYMBOL:OFFSET[SPTR[I]]←$TMPOFF+I-1;
END;
$TMPOFF←$TMPOFF+J;
$$PCODE←$SMPDCLPCODE(OBTYPE,J);
STOKEN←TRUE;
END "temp vars"
ELSE IF OBTYPE=#CM THEN
BEGIN "cmons"
FOR I←1 STEP 1 UNTIL J DO
BEGIN SYMBOL:OFFSET[SPTR[I]]←$SYMOFF+I-1;
ENSYM$(SPTR[I]);
END;
$$PCODE←$PCD11(XXCMVAR,J);
$SYMOFF←$SYMOFF+J;
END "cmons"
ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
$DISPLAYLIST[OBTYPE]←NULL;
END;
! to handle array declarations;
INTERNAL PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
BEGIN "array declaration"
RPTR(EXPR$)PARRAY;
INTEGER NARRAY;
RPTR(EXPR$) ARRAY PLIST[1:10];
RPTR(SYMBOL) ARRAY SYMLST[1:10];
NARRAY←0;
DO BEGIN "get another one"
STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
RPTR(ARRAYREC) DIMREC;
IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
ADIM←0; GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("Need undeclared identifier for array declaration");
ATOKEN←TOKEN; WORD_READ("[");
DO BEGIN
IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
BOUNDS[ADIM*2+1]←$$GTANYEXP("for array dimension",#SC);
BOUNDS[ADIM*2+2]←RGTSCEXP(":","for array dimension");
WORD2_READ(",","]");
ADIM←ADIM+1;
END UNTIL TOKEN="]";
PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(BOUNDS,OBTYPE,ADIM,
NARRAY +(IF CURBLOCK THEN $TMPOFF-1 ELSE $SYMOFF-1));
ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
END UNTIL FINAL;
IF TOKEN=";" THEN STOKEN←TRUE;
PARRAY←NULL_RECORD;
IF CURBLOCK THEN
BEGIN INTEGER I; RPTR(SYMBOL)S;
FOR I←1 STEP 1 UNTIL NARRAY DO
BEGIN
INSRTSYMTREE(S←SYMLST[I],CURBLOCK);
SYMBOL:OFFSET[S]←$TMPOFF;
$TMPOFF←$TMPOFF+1;
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END
ELSE BEGIN
INTEGER I; RPTR(SYMBOL)TEMP;
FOR I← 1 STEP 1 UNTIL NARRAY DO
BEGIN
ENSYM$(TEMP←SYMLST[I]);
SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END;
$$PCODE←PARRAY;
END "array declaration";
INTERNAL PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
GTOKEN;
IF EQU(TOKEN,"PROCEDURE")
THEN BEGIN $COMPILE←$COMPILE+1; PROCDECLPROC(OBTYPE);
$COMPILE←$COMPILE-1; END
ELSE IF EQU(TOKEN,"ARRAY")
THEN ARRAYDECLPROC(OBTYPE)
ELSE BEGIN
STOKEN←TRUE;
SIMPLEDECL(OBTYPE);
END;
END;
INTERNAL PROCEDURE RETURNPROC;
BEGIN RPTR(EXPR$)EXP;
! IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
EXP←NULL_RECORD; GTOKEN;
IF TOKEN="(" THEN
BEGIN EXP←$$GTEXPR; WORD_READ(")");
END
ELSE STOKEN←TRUE;
$$PCODE←$RTNPCODE(EXP);
END;
! setbase,wrist,gather,readwrist,setstiff;
INTERNAL PROCEDURE SETBASEPROC;
$$PCODE←$PCD1(XXSETBAS);
INTERNAL PROCEDURE WRISTPROC;
BEGIN RPTR(EXPR$)K,G;
WORD_READ("(");
K←$GTIDREF(#VT,"argument for WRIST");
WORD_READ(",");
G←$GTIDREF(#VT,"argument for WRIST");
WORD_READ(")");
$DISPLAYLIST[#VT]←NULL;
$$PCODE←$PCDEE1(G,K,XXPWRIST);
END;
IFC #GATHER THENC
PRELOAD_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];
INTERNAL PROCEDURE GATHERPROC;
BEGIN INTEGER STATUS,I; INTEGER S1;
WORD_READ("("); STATUS←0;
DO BEGIN
GTOKEN;
FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
STATUS←STATUS LOR ('1 LSH I);
WORD2_READ(",",")");
END UNTIL TOKEN≠",";
$$PCODE←$PCD11(XXGATHER,STATUS);
END;
ENDC
IFC #WRIST THENC
INTERNAL PROCEDURE READWRISTPROC;
BEGIN STRING COMMAND,FNAME; INTEGER VAL;
VAL←0;FNAME←NULL;
WORD_READ("(");
GTOKEN;
COMMAND←TOKEN;
IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
BEGIN
WORD_READ(",");
IF EQU(COMMAND,"CALIB") THEN
BEGIN
GTOKEN;
VAL←INTSCAN(TOKEN,$BRCHR);
IF VAL<1 OR VAL>6
THEN ERROR("Calib code must be between 1 and 6");
END
ELSE FNAME←NAME_OF_FILE;
END
ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
BEGIN
WORD_READ(",");
FNAME←STR_READ;
END;
WORD_READ(")");
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR("This is an incomplete instruction")
ELSE IF EQU(COMMAND,"READ") THEN
$$PCODE←$PCD1(XXRFORCE)
ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
ERROR("ERROR in reading wrist",$WRMSG[VAL]);
END;
ENDC
INTERNAL PROCEDURE SETSTIFFPROC;
BEGIN
RPTR(EXPR$)E0;
WORD_READ("(");
CASE EXPR$:TYPE[E0←$$GTEXPR] OF
BEGIN
[#SC]
BEGIN
INTEGER NARGS; RPTR(EXPR$)ARRAY E[1:8];
E[NARGS←1]←E0;
GTOKEN;
WHILE TOKEN="," AND NARGS≠6 DO
BEGIN
E[NARGS←NARGS+1]←$$GTANYEXP("argument in SETSTIFF",#SC);
GTOKEN;
END;
IF TOKEN=")" THEN
BEGIN WORD_READ("ABOUT");
E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
END ELSE
IF TOKEN≠"," THEN ERROR("Need comma here")
ELSE
BEGIN E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
WORD_READ(")");
END;
E[8]←$PCD1(XXSETSTF);
$$PCODE←$AAPPEND(E);
END;
[#VT]
BEGIN
RPTR(EXPR$)ARRAY V[1:4];
V[3]←E0;
WORD_READ(",");
V[2]←$$GTANYEXP("argument in STIFFNESS",#VT);
WORD2_READ(",",")");
IF TOKEN="," THEN
BEGIN V[1]←$$GTANYEXP("argument in STIFFNESS",#FR);
WORD_READ(")");
END
ELSE
BEGIN WORD_READ("AT");
V[1]←$$GTANYEXP("argument in STIFFNESS",#FR);
END;
V[4]←$PCD11(XXSTIFF,0);
$$PCODE←$AAPPEND(V);
END;
ELSE ERROR("Cant begin argument for STIFFNESS like this")
END;
END;
INTERNAL PROCEDURE DDTPROC;
$$PCODE←$PCD1(XXDDT);
! vt05,print,prompt,abort,sigwait,pause,enable,val;
INTERNAL PROCEDURE VT05PROC(INTEGER STATE);
$$PCODE←$PCD11(XXDISVT05,STATE);
INTERNAL PROCEDURE VT05CPROC(INTEGER COLOR);
$$PCODE←$PCD11(XXDISCVT05,COLOR);
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE PRINTCODE;
BEGIN RPTR(RSTACK)PPTR;
PPTR←NEW_RSTACK; WORD_READ("(");
DO BEGIN
GTOKEN;
IF TOKEN=dquote
THEN BEGIN "string found"
READTILL(dquote);
RPUSH(PPTR,$PRPCODE(TOKEN))
END
ELSE BEGIN "expression found"
STOKEN←TRUE;
RPUSH(PPTR,$PRVPCODE($$GTEXPR));
END;
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
RETURN($RAPPEND(PPTR));
END;
INTERNAL PROCEDURE PAUSEPROC;
$$PCODE←$PCDA1($$GTANYEXP("PAUSE statement",#SC),XXPAUSE);
INTERNAL PROCEDURE PRINTPROC;
$$PCODE←PRINTCODE;
INTERNAL PROCEDURE ABORTPROC;
$$PCODE←$PCDA1(PRINTCODE,XXABORT);
INTERNAL PROCEDURE PROMPTPROC;
$$PCODE←$PCDA1(PRINTCODE,XXPROMPT);
INTERNAL PROCEDURE SIGWAITPROC(BOOLEAN SIGNAL);
BEGIN INTEGER I;
RPTR(EXPR$)TEMP;
TEMP←$GTIDREF(#EV,"SIGNAL or WAIT");
I←IF SIGNAL THEN XXPSIGNAL ELSE XXPWAIT;
$$PCODE←$PCDA1(TEMP,I);
END;
INTERNAL PROCEDURE ENBLEPROC(BOOLEAN ENABLE);
BEGIN INTEGER I;
RPTR(EXPR$)TEMP; RPTR(SYMBOL)SYM;
TEMP←$$GTIDREF(#CM,SYM,"ENABLE or DISABLE");
I←IF ENABLE THEN XXCMENBL ELSE XXCMDSBL;
$$PCODE←$PCD11(I,SYMBOL:OFFSET[SYM]);
END;
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE VALPROC;
BEGIN BOOLEAN TYPE; STRING S;
WORD_READ("(");
GTOKEN;
IF TOKEN=dquote
THEN BEGIN READTILL(dquote); S←TOKEN; END
ELSE ERROR("Need double quote here");
GTOKEN;
TYPE←TRUE;
IF TOKEN=","
THEN BEGIN
WORD2_READ("WAIT","NOWAIT");
IF EQU(TOKEN,"NOWAIT") THEN TYPE←FALSE;
GTOKEN;
END;
IF TOKEN≠")" THEN ERROR("Need close paren here");
$$PCODE←$PVALPCODE(S,TYPE);
END;
! affix,unfix;
INTERNAL PROCEDURE UNFIXPROC;
BEGIN
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
IF SYMBOL:TYPE[FRM1]=#TR
THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
ELSE ERROR("UNFIX: need a simple trans or a frame here");
WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
IF SYMBOL:TYPE[FRM2]=#TR
THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
ELSE ERROR("UNFIX: need a simple trans or a frame here");
$$PCODE←$PCDEE1(EX2,EX1,XXPUNFIX);
END;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
INTERNAL PROCEDURE AFFIXPROC;
BEGIN
INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
IF SYMBOL:TYPE[FRM1]=#TR
THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
ELSE ERROR("AFFIX: need a simple trans or a frame here");
WORD_READ("TO");
EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
IF SYMBOL:TYPE[FRM2]=#TR
THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
ELSE ERROR("AFFIX: NEED A SIMPLE TRANS OR A FRAME HERE");
GTOKEN(FALSE);
TEMP←NULL_RECORD;
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
TEMP←$$GTANYEXP("offset part of AFFIX statement",#FR);
GTOKEN(FALSE);
END "AT";
IF FINAL
THEN AFFTYPE←#RGDLK
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY") THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY") THEN AFFTYPE← #RGDLK
ELSE ERROR("invalid affix type");
END "D";
$$PCODE←$AFXPCODE(EX1,EX2,AFFTYPE,TEMP);
END ;
! coordproc;
INTERNAL PROCEDURE COORDPROC (INTEGER ELEMENT,TYPE);
BEGIN
RPTR(EXPR$) EX1,EX2; RPTR(SYMBOL) S;INTEGER TYPEF;
S←NULL_RECORD; ! element=0,1,2,3 depending on instr;
WORD_READ("(");
EX1←IDREF(S); ! read the argument&look for predeclared;
IF PRDECL(S) THEN
ERROR("You cannot change the value of"&SYMBOL:PNAME[S] );
! check for correct type of argument;
CASE (TYPEF←EXPR$:TYPE[EX1]) OF
BEGIN
[#SC][#RT] ERROR("unexpected type");
[#VT] IF ELEMENT=0 THEN ERROR("unexpected type");
ELSE
END;
WWORD_READ(")","←");
! reads the expression according to the type;
CASE TYPE OF
BEGIN
[#SC] EX2←$$GTANYEXP("X-Y-Z coord",#SC);
[#VT] EX2←$$GTANYEXP("POS",#VT);
[#RT] EX2←$$GTANYEXP("ORIENT",#RT);
ELSE ERROR("COORDPROC: unexpected type")
END;
$DISPLAYLIST[TYPEF]←NULL;
$$PCODE←$COORDPCODE(EX1,EX2,ELEMENT,TYPE);
END;
! assignproc,setspeedproc;
! assigns to first the expression following, assuming that FIRST has not
been declared. This works only for simple variables;
RECURSIVE PROCEDURE ASGEX3(STRING FIRST);
BEGIN RPTR(EXPR$)LHS,RHS; RPTR(SYMBOL)S;
RHS←$$GTEXPR;
S←INSERT(FIRST,EXPR$:TYPE[RHS]);
LHS←EXPR$ID(S);
$DISPLAYLIST[EXPR$:TYPE[LHS]]←NULL;
$$PCODE←$PCDEE1(RHS,LHS,XXCHNGS);
END;
INTERNAL RECURSIVE PROCEDURE ASGEX2(RPTR(SYMBOL)S;RPTR(EXPR$)LHS);
BEGIN RPTR(EXPR$)RHS; INTEGER TY;
RHS←$$GTEXPR;
IF (TY←SYMBOL:TYPE[S])=#FR AND EXPR$:TYPE[RHS]=#TR THEN
EXPR$:TYPE[RHS]←#FR
ELSE IF TY=#TR AND EXPR$:TYPE[RHS]=#FR
THEN CNVRTR(S,SYMBOL:PNAME[S])
ELSE IF EXPR$:TYPE[RHS]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
$DISPLAYLIST[EXPR$:TYPE[LHS]]←NULL;
$$PCODE←$PCDEE1(RHS,LHS,XXCHNGS);
END;
INTERNAL RECURSIVE PROCEDURE ASSIGNPROC;
BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
BOOLEAN PAS;
FIRST←TOKEN; EE←NULL_RECORD;
IF (SS←TOKENPTR)≠NULL_RECORD THEN
IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
THEN BEGIN $$PCODE←PREF(TOKENPTR);refproc←ss;
RETURN; END
ELSE BEGIN STOKEN←TRUE; EE←IDREF(SS); END;
! EE=NULL_RECORD implies is an undeclared id;
WORD2_READ("←",":");
IF TOKEN="←"
THEN BEGIN
IF EE AND EXPR$:TYPE[EE]=#CM THEN ERROR("Can't have ← after a label");
GTOKEN;
IF TOKEN="←" THEN PAS←TRUE ELSE BEGIN STOKEN←TRUE; PAS←FALSE; END;
IF EE THEN IF (NOT PAS) AND PRDECL(SS) THEN
ERROR("You cannot change the value of "&SYMBOL:PNAME[SS])
ELSE ASGEX2(SS,EE)
ELSE IF $LEVEL=0 THEN ASGEX3(FIRST)
ELSE ERROR("Cant make implicit declaration inside a block");
IF PAS THEN $$PCODE←NULL_RECORD;
END
ELSE BEGIN
BOOLEAN DEFER;
IF EE=NULL_RECORD
THEN ERROR("can't handle undeclared labels yet")
ELSE IF EXPR$:TYPE[EE]≠#CM
THEN ERROR("Need label before colon")
ELSE IF CMON:BODY[SYMBOL:OBJECT[SS]]
THEN ERROR(SYMBOL:PNAME[SS]&" has been used already");
GTOKEN;
IF EQU(TOKEN,"DEFER")
THEN DEFER←TRUE ELSE BEGIN DEFER←FALSE; STOKEN←TRUE; END;
WORD_READ("ON");
ONPROC(SS,DEFER);
CMON:BODY[SYMBOL:OBJECT[SS]]←$CLNSAVE;
END;
END;
INTERNAL PROCEDURE SETSPEEDPROC;
$$PCODE←$PCDA1(RGTSCEXP("←","SPEED_FACTOR"),XXSETSPEED);
! loadproc;
DEFINE #BUFSIZE=256;
INTEGER ARRAY BUFVAL[1:#BUFSIZE]; ! dump/load buffer;
INTEGER BUFPTR; ! pointer to BUFVAL;
INTEGER BUFCH; ! channel used by LOAD/DUMP;
RPTR(BLOCKREC)BLOCK; ! local symbol table for frame arrays;
! output one block=(# of words)+ BUFVAL and start a new buffer;
PROCEDURE NEWBUF;
BEGIN
IF BUFPTR=0 THEN RETURN;
WORDOUT(BUFCH,BUFPTR);ARRYOUT(BUFCH,BUFVAL[1],BUFPTR); BUFPTR←0;
END;
! read from the file one block into BUFVAL and return the # of words;
INTEGER PROCEDURE READBUF;
BEGIN
INTEGER MAXPTR;
BUFPTR←0;ARRYIN(BUFCH,BUFVAL[1],MAXPTR←WORDIN(BUFCH));
IF MAXPTR≤#BUFSIZE THEN RETURN(MAXPTR)
ELSE BEGIN RELEASE(BUFCH);
ERROR("LOAD ERROR: file not dumped by POINTY"); END;
END;
! pushes integer J into the buffer (as ipush);
SIMPLE PROCEDURE INTPUSH(INTEGER J);
BUFVAL[BUFPTR←BUFPTR+1]←J;
! pushes real value R into buffer ;
SIMPLE PROCEDURE FLPUSH(REAL R);
MEMORY[LOCATION(BUFVAL[BUFPTR←BUFPTR+1]),REAL]←R;
! gets integer from the buffer;
INTEGER PROCEDURE INTGET;
RETURN(BUFVAL[BUFPTR←BUFPTR+1]);
! gets real number from the buffer;
REAL PROCEDURE FLGET;
RETURN(MEMORY[LOCATION(BUFVAL[BUFPTR←BUFPTR+1]),REAL]);
! the string is converted into numbers and placed in BUFVAL;
PROCEDURE NUMBFY(STRING NAME);
BEGIN
WHILE NAME DO BEGIN
INTPUSH(CVASC(NAME));NAME←NAME[6 TO ∞];
END;
BUFVAL[BUFPTR]←BUFVAL[BUFPTR] LOR 1; comment last bit=1 for last word;
END;
! the numbers taken from BUFVAL are converted into string;
STRING PROCEDURE STRINGFY;
BEGIN
STRING ST; ST←NULL;
DO ST←ST&CVASTR(INTGET)
UNTIL BUFVAL[BUFPTR] LAND 1; comment check when last bit=1;
RETURN(ST);
END;
SIMPLE PROCEDURE HEAD_WRITE;
BEGIN BUFPTR←0;NUMBFY("POINTYDUMP");NEWBUF;END;
SIMPLE PROCEDURE HEAD_READ;
BEGIN
READBUF;
IF ¬EQU(STRINGFY,"POINTYDUMP")
THEN BEGIN
RELEASE(BUFCH);ERROR("LOAD error: file not dumped by POINTY");
END;
END;
! return the pointer to dad, if it's a frame, otherwise to station;
RPTR (SYMBOL) PROCEDURE CHECKDAD(STRING DAD,NAME);
BEGIN
RPTR(SYMBOL)SYMDAD;
IF SYMBOL:TYPE[SYMDAD←SYM_PTR_OF(DAD)]≠#FR
THEN BEGIN PRINT(SYMBOL:PNAME[SYMDAD]&" is not a frame. I try to affix "
&NAME&" to STATION"&crlf);RETURN(WORLD);END
ELSE RETURN(SYMDAD);
END;
! load data part reading values of HOWMANY elements and construct the expr$;
RPTR(EXPR$)PROCEDURE DATALOAD(INTEGER TYPE;INTEGER HOWMANY(1));
BEGIN
PRELOAD_WITH 1,3,3,6,6,0;
OWN INTEGER ARRAY MULTIPLIER[#SC:#EV];
INTEGER I,N;
IF (N←MULTIPLIER[TYPE]*HOWMANY)=0 THEN RETURN(NULL_RECORD); ! that for βexpr$;
FOR I←1 STEP 1 UNTIL N DO FPUSH(FLGET);
RETURN(βEXPR$);
END;
PROCEDURE MACROLOAD(STRING NAME);
BEGIN
RPTR(MACRO)MCPTR;INTEGER N,I;
MCPTR←NEW_RECORD(MACRO);
MACRO:HEAD[MCPTR]←STRINGFY;
IF (N←MACRO:NPARAM[MCPTR]←INTGET)≠0
THEN BEGIN
STRING ARRAY PRLIST[1:N];
FOR I←1 STEP 1 UNTIL N DO PRLIST[I]←STRINGFY;
MEMORY[LOCATION(MACRO:PRLIST[MCPTR])]↔MEMORY[LOCATION(PRLIST)];
END;
MACRO:BODY[MCPTR]←STRINGFY;
IF UNDECLARED(NAME)
THEN ENSYM(NAME,#MC,MCPTR)
ELSE PRINT(NAME&" is not loaded because existent"&crlf);
END;
! loads one variable (any type and access);
RPTR(EXPR$) PROCEDURE VAR$LOAD;
BEGIN "VARLOAD"
INTEGER TYPE,ACCESS,TYPACC,HOW;STRING NAME;RPTR(SYMBOL)SYMPTR,SYMDAD;
RPTR(EXPR$)TEMP;TEMP←NULL_RECORD;
TYPACC←INTGET;TYPE←TYPACC MOD 10;ACCESS←TYPACC DIV 10;
NAME←STRINGFY;
CASE ACCESS OF BEGIN "case"
[#SIMPLE] BEGIN
IF TYPE≠#MC
THEN BEGIN
TEMP←DATALOAD(TYPE);
IF TYPE=#FR THEN
IF (HOW←INTGET)≠#INDLK THEN SYMDAD←CHECKDAD(STRINGFY,NAME);
IF UNDECLARED(NAME)
THEN BEGIN
ENSYM$(SYMPTR←NNWR(NAME,TYPE,ACCESS),TYPE);
RETURN(L$PCODE(SYMPTR,SYMDAD,TEMP,TYPE,HOW));
END
ELSE PRINT(NAME&" is not loaded because existent"&crlf);
END
ELSE MACROLOAD(NAME);
END;
[#ARRAY_ELEMENT] BEGIN "frame array elements"
TEMP←DATALOAD(TYPE);
IF (HOW←INTGET)≠#INDLK THEN SYMDAD←CHECKDAD(STRINGFY,NAME);
IF SEARCHBLOCK(ARNAME(NAME),BLOCK)≠NULL_RECORD
THEN RETURN(L$PCODE(SYMPTR←NNWR(NAME,TYPE,ACCESS),
SYMDAD,TEMP,TYPE,HOW,SYMBOL:OFFSET[$YM_PTR(NAME)]));
END "frame array elements";
[#ARRAY] BEGIN
INTEGER I,DIM,EL;INTEGER ARRAY LB,UB,MUL[1:5];
DIM←INTGET;EL←INTGET;
FOR I←1 STEP 1 UNTIL DIM DO BEGIN
LB[I]←INTGET;UB[I]←INTGET;MUL[I]←INTGET;END;
IF TYPE≠#FR THEN TEMP←DATALOAD(TYPE,EL);
IF UNDECLARED(NAME)
THEN BEGIN
ENSYM$(SYMPTR←MK_SYM(NAME,TYPE,NEW_RECORD(ARRAYREC),#ARRAY),TYPE);
SYMBOL:OFFSET[SYMPTR]←$SYMOFF;$SYMOFF←$SYMOFF+1;
ARRAYREC:#DIM[SYMBOL:OBJECT[SYMPTR]]←DIM;
SYMPTR←NWAREC(SYMPTR,EL,LB,UB,MUL);
IF TYPE=#FR THEN INSRTSYMTREE(SYMPTR,BLOCK);
RETURN(IF TEMP≠NULL_RECORD
THEN L$ARRPCODE(SYMPTR,TYPE,TEMP)
ELSE L$ARRDCLPCODE(SYMPTR,TYPE));
END
ELSE PRINT(NAME&" is not loaded because existent"&crlf);
END
END "case";
RETURN(NULL_RECORD);
END "VARLOAD";
INTERNAL PROCEDURE LOADPROC(STRING FILE);
BEGIN
INTEGER MAXPTR,EOF,BR,I;RPTR(RSTACK)LSTACK; RPTR(EXPR$)TEMP;
IF FILE_ABSENT(FILE) THEN ERROR("LOAD error: nonexistent file "&FILE);
BUFCH←OREADFILE(FILE,EOF,'10); ! binary mode;
HEAD_READ;BLOCK←NEW_RECORD(BLOCKREC);
DO BEGIN "READ LOOP"
MAXPTR←READBUF;
LSTACK←NEW_RSTACK;
WHILE BUFPTR<MAXPTR DO
IF (TEMP←VAR$LOAD)≠NULL_RECORD THEN RPUSH(LSTACK,TEMP);
IF RSTACK:TOP[LSTACK] THEN $EXECUTE($RAPPEND(LSTACK));
END "READ LOOP"
UNTIL MAXPTR=0;
RELEASE(BUFCH);
FOR I←#MIN STEP 1 UNTIL #MAX DO $DISPLAYLIST[I]←NULL;
END;
! dumpproc;
! dump type and name of a variable;
PROCEDURE SYMBDMP(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
IF BUFPTR≥#BUFSIZE-20 THEN NEWBUF;
INTPUSH(SYMBOL:ACCESS[SYMPTR]*10+TYPE);
NUMBFY(SYMBOL:PNAME[SYMPTR]);
END;
! dump the data part of a variable;
PROCEDURE DATADMP(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
INTEGER I,HOW; RANY OBJECT;
IF $ELFABORTED OR $NOELF OR TYPE=#MC
THEN OBJECT←SYMBOL:OBJECT[SYMPTR] ELSE OBJECT←$EVAL11(SYMPTR);
CASE TYPE OF BEGIN
[#SC] FLPUSH(SCALAR:VALUE[OBJECT]);
[#VT] BEGIN FLPUSH(VECTOR:XC[OBJECT]);
FLPUSH(VECTOR:YC[OBJECT]);FLPUSH(VECTOR:ZC[OBJECT]);END;
[#RT] FOR I←4 STEP 1 UNTIL 6 DO FLPUSH(ROT:XF[OBJECT][I]);
[#TR] FOR I←1 STEP 1 UNTIL 6 DO FLPUSH(TRANS:XF[OBJECT][I]);
[#FR] BEGIN FOR I←1 STEP 1 UNTIL 6 DO FLPUSH(FRAME:XF[OBJECT][I]);
INTPUSH(HOW←FRAME:HOWLINKED[OBJECT]);
IF HOW≠#INDLK THEN NUMBFY(FRAME:PNAME[FRAME:DAD[OBJECT]]);END;
[#MC] BEGIN RPTR(MACRO)MCPTR;
NUMBFY(MACRO:HEAD[OBJECT]);
INTPUSH(HOW←MACRO:NPARAM[OBJECT]);
FOR I←1 STEP 1 UNTIL HOW DO NUMBFY(MACRO:PRLIST[OBJECT][I]);
NUMBFY(MACRO:BODY[OBJECT]); END
END;
END;
! dump the frame tree;
RECURSIVE PROCEDURE FRAMEDMP(RPTR(FRAME) ND);
BEGIN
INTEGER I;RPTR(FRAME) SN;STRING S;
IF NOT(ND=F_WRLD OR EQU(S←FRAME:PNAME[ND],"BPARK") OR EQU(S,"YPARK")
OR EQU(S,"BARM")OR EQU(S,"YARM")OR EQU(S,"BGRASP"))
THEN BEGIN
SYMBDMP(FRAME:SYM[ND],#FR);DATADMP(FRAME:SYM[ND],#FR);
END;
SN←FRAME:SON[ND];
WHILE SN≠NULL_RECORD DO
BEGIN
FRAMEDMP(SN);SN←FRAME:EBRO[SN];
END;
END;
PROCEDURE ARRDCLDMP(RPTR(SYMBOL)SYMPTR;INTEGER TYPE);
BEGIN
RPTR(ARRAYREC)OBJECT;INTEGER I,DIM,EL,SIZE;
PRELOAD_WITH 1,3,3,6,0,0;
OWN INTEGER ARRAY MULTIP[#SC:#EV]; ! arrays of frames dumped with the tree;
OBJECT←SYMBOL:OBJECT[SYMPTR];
! check how many words required;
SIZE←3*ARRAYREC:#DIM[OBJECT]+ARRAYREC:#EL[OBJECT]*MULTIP[TYPE] + 5;
IF #BUFSIZE<SIZE
THEN BEGIN RELEASE(BUFCH);
ERROR("DUMP error: array "&symbol:pname[symptr]&" too big");END
ELSE IF #BUFSIZE-BUFPTR<SIZE THEN NEWBUF;
INTPUSH(DIM←ARRAYREC:#DIM[OBJECT]);INTPUSH(EL←ARRAYREC:#EL[OBJECT]);
FOR I←1 STEP 1 UNTIL DIM DO BEGIN
INTPUSH(ARRAYREC:LB[OBJECT][I]);INTPUSH(ARRAYREC:UB[OBJECT][I]);
INTPUSH(ARRAYREC:MUL[OBJECT][I]); END;
END;
INTERNAL PROCEDURE DUMPPROC(STRING FILE);
BEGIN "dump"
RPTR(SYMBOL) SYMPTR;INTEGER I,TYPE,FLAG;integer array fileinf[1:3];
FILEINF[1]←CVFIL(FILE,FILEINF[2],FILEINF[3]);
IF FILEINF[1]=CVSIX("POINTY") THEN ERROR("DUMP: dont use dumpfile POINTY");
IF FILEINF[2]≠CVSIX("DMP") THEN
BEGIN PRINT("I will give extension of .DMP",CRLF);
FILEINF[2]←CVSIX("DMP");
END;
IF NOT FILE_ABSENT(FILE←
cv6str(FILEINF[1])&"."&cv6str(FILEINF[2])&cv6str(FILEINF[3]))
THEN BEGIN
PRINT("file "&FILE&" exists. Type Y to replace"); CLRBUF;
IF INCHRW≠"Y" THEN ERROR("DUMP not executed") ELSE PRINT(CRLF);
END;
BUFCH←OWRITEFILE(FILE,'10);
HEAD_WRITE;
FOR I←OFFSET[RES_OFFSET,#FR]+1 STEP 1 UNTIL $ENTRY[#FR] DO
IF (SYMPTR←$YMTAB[#FR,I])≠NULL_RECORD AND SYMBOL:ACCESS[SYMPTR]=#ARRAY
THEN BEGIN
SYMBDMP(SYMPTR,#FR);ARRDCLDMP(SYMPTR,#FR);
END;
FRAMEDMP(F_WRLD);NEWBUF;
FOR TYPE←#SC,#VT,#RT,#TR,#EV,#MC DO BEGIN "type"
FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
IF (SYMPTR←$YMTAB[TYPE,I])≠NULL_RECORD THEN
BEGIN
SYMBDMP(SYMPTR,TYPE);
CASE SYMBOL:ACCESS[SYMPTR] OF BEGIN "case"
[#SIMPLE] IF TYPE≠#EV THEN DATADMP(SYMPTR,TYPE);
[#ARRAY] BEGIN
ARRDCLDMP(SYMPTR,TYPE);
IF TYPE≠#EV THEN
BEGIN
INTEGER J,EL;
EL←ARRAYREC:#EL[SYMBOL:OBJECT[SYMPTR]];
FOR J←1 STEP 1 UNTIL EL DO
DATADMP(ARRAYREC:PTR[SYMBOL:OBJECT[SYMPTR]][J],TYPE);
END;
END;
[#PROCEDURE]print("DUMP of procedures not yet implemented"&crlf)
END "case";
END;
NEWBUF;
END "type";
CLOSE(BUFCH);RELEASE(BUFCH);
END "dump";
END "PPROC";